perm filename TASTER.SAI[1,LES]1 blob sn#006738 filedate 1973-01-25 generic text, type T, neo UTF8
00100	BEGIN "TASTER - L. Earnest, December 1971"
00200	REQUIRE "GOOD.SAI[1,LES]" SOURCE_FILE;
00300	
00400	DEFINE WMAX="40";	⊂ max. number of wines;
00500	DEFINE PMAX="40";	⊂ max. number of people;
00600	DEFINE INST="""TASTER.LES[W,LES]""";	⊂ program documentation;
00700	
00800	INTEGER W,SCALE,I;
00900	STRING S,T,FILE,DATE;
01000	LABEL BAD;
01100	PRELOAD_WITH "January", "February", "March", "April", "May", "June",
01200		"July", "August", "September", "October", "November", "December";
01300	STRING ARRAY MONTH[1:12];
01400	
01500	STRING PROC TODAY;
01600		BEGIN INTEGER I;  I←CALL(0,"DATE");
01700		SETFORMAT(0,0);	⊂ ((year-1964)*12+month-1)*31+day-1;
01800		RETURN(CVS(I MOD 31+1)&" "&MONTH[(I←I%31)MOD 12+1]&CVS(I%12+1964))
01900		END;
02000	
02100	PREPARE;
02200	IF (I←ASK("Do you know how to run this program?  "))="N" ∨ I="n" THEN BEGIN
02300		UP;  DSKI;  FILI(INST);
02400		DO SAY(INPUT(INCH,2)) UNTIL EOF;
02500		SAY(CRLF&"This information comes from file "&INST&CRLF&LF);
02600		RELEASE(INCH);
02700		END;
02800	
02900	DEFINE URP(S)="BEGIN SAY(S&CRLF); RELEASE(INCH); GO TO BAD END";
03000	
03100	BAD:
03200	W←SCALE←0;
03300	IF LN(FILE←ASK("Input file, if any:  ")) THEN BEGIN "read"
03400		DSKI;  FILI(FILE);  IF FLAG THEN URP("""File not found""");
03500		IF EQU(T←TOTAB(S←INLINE),"DATE:") THEN BEGIN
03600			DATE←S;  T←TOTAB(S←INLINE);
03700			END;
03800		IF ¬EQU(T,"WINES:") ∨ (W←CVD(S))≤0 ∨ W>WMAX THEN URP("""Wine number error""");
03900		IF ¬EQU(TOTAB(S←INLINE),"SCALE:") ∨ (SCALE←CVD(S))<0 ∨ SCALE>25
04000		    THEN URP("""Scale error""");
04100		S←INLINE;	⊂ flush blank line;
04200		END "read"
04300	ELSE BEGIN "ask"
04400		DO W←CVD(ASK("# of wines:  ")) UNTIL 0<W≤WMAX;
04500		SCALE←CVD(ASK("SCALE:  "));
04600		END;
     

00100	BEGIN "ARRAYS"
00200	STRING ARRAY WINE[1:W],NOTES[1:W],PEOPLE[1:PMAX];
00300	INTEGER ARRAY YEAR[1:W],SCORE[1:PMAX,1:W],DRINK[1:PMAX,1:W];
00400	INTEGER P,YR;	⊂ PEOPLE COUNTER, CURRENT YEAR;
00500	
00600	DEFINE BARF(S)="BEGIN OUTSTR(S&CRLF);  RETURN(FALSE) END";
00700	
00800	BOOLEAN PROC WININ(INTEGER LOC; STRING WIN);  BEGIN
00900		STRING F;  INTEGER Y;
01000		IF LN(F←TOTAB(WIN)) THEN BEGIN "CHANGE NAME"
01100			Y←SCAN(F,3,BRK);  "FLUSH LEADING SPACES"
01200			IF F="'" THEN F←F[2 TO ∞]
01300			    ELSE IF EQU(F[1 FOR 2],"NV") ∨ EQU(F[1 FOR 2],"nv")
01400			    THEN F←F[3 TO ∞];
01500			IF F<"0" ∨ F>"9" THEN Y←0
01600			    ELSE IF 100≤(Y←INTSCAN(F,BRK))<1800 ∨ Y>YR
01700			    THEN BARF("""illegal year""");
01800			YEAR[LOC]← IF Y=0 ∨ Y≥100  THEN Y ELSE IF (Y←Y-YR MOD 100)>0
01900			    THEN YR-100+Y ELSE YR+Y;
02000			Y←SCAN(F,3,BRK);  "FLUSH SPACES"
02100			WINE[LOC]←F;
02200			END "CHANGE NAME";
02300		IF LN(WIN) THEN NOTES[LOC]←WIN; "STORE NOTES IF NON-NULL"
02400		RETURN(TRUE)
02500		END;
02600	
02700	BOOLEAN PROC SCORIN(STRING SC);  BEGIN
02800		INTEGER I,J,V;
02900		FOR I ⊃ W DO BEGIN
03000			SCORE[P+1,I]←V←INTSCAN(SC,BRK);
03100	 		IF V≤0 THEN BARF("IF LN(SC)=0 THEN ""Not enough scores given""
03200			    ELSE ""Illegal score of 0""");
03300			IF SCALE=0 ∧ V>W ∨ SCALE ∧ V>SCALE THEN
03400			     BARF("CVS(V)&"" is too large""");
03500			IF SCALE=0 THEN FOR J ⊃ I-1 DO IF V=SCORE[P+1,J] THEN
03600			    BARF("""Rank ""&CVS(V)&"" duplicated""");
03700			END;
03800		END;
03900	
04000	PROC DRINKIN(INTEGER LOC; STRING Y);  BEGIN
04100		INTEGER I;
04200		FOR I ⊃ W DO DRINK[LOC,I]←INTSCAN(Y,BRK);
04300		END;
04400	
04500	P←0;  YR←CALL(0,"DATE")DIV(12*31)+1964;  "YR is now the current year"
04600	
04700	IF LN(FILE) THEN BEGIN "readmore"
04800		FOR I ⊃ W DO IF ¬WININ(I,S←INLINE) THEN URP(S);
04900		S←INLINE;  ⊂ flush blank line;
05000		WHILE LN(S←INLINE) DO BEGIN "people scores"
05100			IF ¬SCORIN(TOTAB(S)) THEN URP("""Rest of line:  ""&S");
05200			DRINKIN(P←P+1,TOTAB(S));
05300			IF LN(PEOPLE[P]←S)=0 THEN URP("""Missing TAB or name""");
05400			END "people scores";
05500		RELEASE(INCH);
05600		END "readmore";
05700	
     

00100	WHILE TRUE DO BEGIN "COMMANDS"
00200	INTEGER COM,B;  STRING BASE;
00300	
00400	STRING PROC WINO(INTEGER L);
00500		RETURN((IF YEAR[L] THEN CVS(YEAR[L]) ELSE " NV ")&" "&WINE[L]);
00600	
00700	STRING PROC WINID(INTEGER N);
00800		RETURN(IF LN(BASE) THEN "  "&(BASE+N-1) ELSE CVS(B+N));
00900	
01000	DEFINE NIX(S)="BEGIN OUTSTR(S&CRLF);  RETURN  END";
01100	
01200	STRING PROC RS;  RETURN(IF SCALE THEN "scores" ELSE "ranks");
01300	
01400	PROC WINUM;  BEGIN
01500		INTEGER I;
01600		SETFORMAT(3,0);
01700		FOR I ⊃ W DO SAY(WINID(I));
01800		SAY("  WINE"&CR);
01900		FOR I ⊃ W DO SAY(" __");
02000		UP END;
02100	
02200	PROC HELP;  SAY("
02300	COMMANDS:
02400	N - Name wines
02500	P - Print forms
02600	I - Input ratings
02700	T - enter Tasting date
02800	L - List wines
02900	R - show Ratings by person
03000	D - show Distribution of scores
03100	C - show Consensus rank of wines
03200	Y - show drinkable Year by person
03300	A - show All (L,R,D,C,Y)
03400	B - set Base number or letter for wines
03500	F - name File used by W command
03600	W - Write data file
03700	H - Help!  show this list
03800	
03900	For more complete descriptions of these commands,
04000	list file "&INST&CRLF&LF);
04100	
04200	PROC NAME;  BEGIN
04300		INTEGER I;  STRING S;
04400		SETFORMAT(0,0);
04500		FOR I ⊃ W DO IF LN(S←ASK(WINID(I)&". "&WINO(I)&TAB&NOTES[I]&"  "))
04600		    THEN WHILE ¬WININ(I,S) DO IF LN(S←ASK("Reenter:  "))=0 then done;
04700		END;
04800	
04900	PROC PRINT;	BEGIN  INTEGER I,J,P;
05000		P←CVD(ASK("# OF COPIES:  "));
05100		SETFORMAT(4,0);
05200		FOR I ⊃ P DO BEGIN "FORMS"
05300			SAY(CRLF&LF&LF&"Name:"&CRLF&LF&"WINE #:");
05400			FOR J ⊃ W DO SAY(WINID(J));
05500			SAY(CRLF&LF&RS&":"&CRLF&LF&"Years:"&CRLF&LF&LF);
05600			END "FORMS"
05700		END "PRINT";
05800	
05900	PROC INPUT;  BEGIN
06000		STRING NAM,S;  INTEGER PC,I;
06100		SETFORMAT(0,0);
06200		WHILE LN(S←ASK("name:  ")) DO BEGIN "ENTER SCORES"
06300			IF S≠"." THEN NAM←S
06400			    ELSE IF LN(NAM) THEN SAY(TAB&NAM&CRLF)  ELSE RETURN;
06500			FOR PC ⊃ P DO IF EQU(NAM,PEOPLE[PC]) THEN
06600			    BEGIN SAY("So you've changed your mind, eh?"&CRLF);  DONE END;
06700			IF PC>PMAX THEN NIX("""Sorry, no more room""");
06800			IF LN(S←ASK(RS&":  ")) ∧ SCORIN(S) THEN BEGIN
06900				IF PC>P THEN PEOPLE[P←PC]←NAM
07000				    ELSE FOR I ⊃ W DO SCORE[PC,I]←SCORE[P+1,I];
07100				DRINKIN(PC,ASK("Year to drink:  "));
07200				END;
07300			END "ENTER SCORES"
07400		END "INPUT";
07500	
07600	PROC WRITE;  BEGIN
07700		INTEGER I,J;
07800		SETFORMAT(0,0);
07900		DSKO; FILO(FILE); IF FLAG THEN BEGIN
08000			SAY("File "&FILE&" cannot be written"&CRLF);
08100			RELEASE(OUCH);  RETURN
08200			END;
08300		OUT(OUCH,"DATE:	"&(IF LN(DATE) THEN DATE ELSE TODAY)&CRLF);
08400		OUT(OUCH,"WINES:	"&CVS(W)&CRLF);
08500		OUT(OUCH,"SCALE:	"&CVS(SCALE)&CRLF&CRLF);
08600		FOR I ⊃ W DO OUT(OUCH,WINO(I)&TAB&NOTES[I]&CRLF);
08700		OUT(OUCH,CRLF);  SETFORMAT(3,0);
08800		FOR I ⊃ P DO BEGIN
08900			FOR J ⊃ W DO OUT(OUCH,CVS(SCORE[I,J]));
09000			OUT(OUCH,TAB);
09100			FOR J ⊃ W DO OUT(OUCH,CVS(DRINK[I,J])&" ");
09200			OUT(OUCH,TAB&PEOPLE[I]&CRLF);
09300			END;
09400		RELEASE(OUCH);
09500		END;
09600	
09700	PROC LIST;  BEGIN
09800		INTEGER I;
09900		IF LN(DATE) THEN SAY(LF&"Tasting of "&DATE&CRLF&LF);
10000		SETFORMAT(0,0);
10100		FOR I ⊃ W DO SAY(WINID(I)&". "&WINO(I)&CRLF);
10200		UP END;
10300	
10400	PROC RATINGS;  BEGIN
10500		INTEGER I,J;
10600		SETFORMAT(0,0);
10700		SAY(CRLF&RS&" by person"&(IF SCALE THEN " (Scale of "&CVS(SCALE)&")"
10800		    ELSE NULL)&CRLF&LF);
10900		WINUM;
11000		FOR I ⊃ P DO BEGIN
11100			FOR J ⊃ W DO SAY(CVS(SCORE[I,J]));
11200			SAY("  "&PEOPLE[I]&CRLF);
11300			END;
11400		UP END "RATINGS";
11500	
11600	PROC DISTRIBUTION;  BEGIN
11700		INTEGER I,J,N,M;
11800		INTEGER ARRAY DIST[1:M←(IF SCALE THEN SCALE ELSE W)];
11900		SETFORMAT(3,0);  SAY(CRLF&"Distribution of "&RS&CRLF&LF);
12000		FOR I ⊃ M DO SAY(CVS(I));  SAY(CR);
12100		FOR I ⊃ M DO SAY(" __");  UP;
12200		FOR I ⊃ W DO BEGIN
12300			FOR J ⊃ M DO DIST[J]←0;
12400			FOR J ⊃ P DO BEGIN
12500				N←SCORE[J,I];
12600				DIST[N]←DIST[N]+1;
12700				END;
12800			FOR J ⊃ M DO SAY(CVS(DIST[J]));
12900			SAY(WINID(I)&". "&WINO(I)&CRLF);
13000			END;
13100		UP END "DISTRIBUTION";
13200	
13300	PROC CONSENSUS; IF P>0 THEN BEGIN "CONS"
13400		INTEGER I,J,K,N,N2,MN,MX;  REAL M;
13500		INTEGER ARRAY ORDER,MINI,MAXI,SQUARES[1:W];
13600		EXTERNAL FORTRAN REAL PROC SQRT(REAL N);
13700		SAY(CRLF&"consensus "&RS&CRLF&
13800		    "mean  dev min max  #"&CR&"____ ____ ___ ___"&CRLF);
13900		FOR I ⊃ W DO BEGIN
14000			N←MN←MX←SCORE[1,I];
14100			N2←N*N;
14200			FOR J←2 THRU P DO BEGIN
14300				N←N+(K←SCORE[J,I]);
14400				N2←N2+K*K;
14500				MN←MN MIN K;
14600				MX←MX MAX K;
14700				END;
14800			ORDER[I]←IF SCALE THEN N ELSE -N;
14900			MINI[I]←MN;  MAXI[I]←MX;  SQUARES[I]←N2;
15000			END;
15100		SETFORMAT(2,1);
15200		FOR I ⊃ W DO BEGIN "RANK"
15300			N←1;
15400			FOR J←2 THRU W DO IF ORDER[J]>ORDER[N] THEN N←J;
15500			SAY(CVF(M←ABS ORDER[N]/P)&
15600			    RIGHT(5,CVF(SQRT((SQUARES[N]-M*ABS ORDER[N])/(P-1))))&
15700			    " "&CVS(MINI[N])&"  "&CVS(MAXI[N])&"  "&WINID(N)&".  "&WINO(N)&CRLF);
15800			ORDER[N]←-1000000;  "DELETE IT"
15900			END "RANK";
16000		UP END "CONS";
16100	
16200	PROC YEARS;  BEGIN
16300		INTEGER I,J,T,M,SUM;
16400		STRING S;
16500		SAY(CRLF&"Estimated year when drinkable"&CRLF&LF);
16600		WINUM;
16700		FOR I ⊃ P DO BEGIN "BY PEOPLE"
16800			S←NULL;  M←0;
16900			FOR J ⊃ W DO IF (T←DRINK[I,J]) THEN
17000			    BEGIN  M←M+T;  S←S&CVS(T);  END
17100			    ELSE S←S&"   ";
17200			IF M THEN SAY(S&"  "&PEOPLE[I]&CRLF);
17300			END;
17400		UP;
17500		FOR I ⊃ W DO BEGIN "EARLIEST"
17600			M←99999;
17700			FOR J ⊃ P DO IF (T←DRINK[J,I]) ∧ T<M THEN M←T;
17800			SAY(IF M<99999 THEN CVS(M) ELSE "   ");
17900			END;
18000		SAY("  earliest"&CRLF);
18100		FOR I ⊃ W DO BEGIN "LATEST"
18200			M←0;
18300			FOR J ⊃ P DO M←M MAX DRINK[J,I];
18400			SAY(IF M THEN CVS(M) ELSE "   ");
18500			END;
18600		SAY("  latest"&CRLF);
18700		FOR I ⊃ W DO BEGIN "MEAN"
18800			SUM←M←0;
18900			FOR J ⊃ P DO IF (T←DRINK[J,I]) THEN
19000				BEGIN SUM←SUM+T;  M←M+1;  END;
19100			SAY(IF M THEN CVS((SUM+M%2)%M) ELSE "   ");
19200			END;
19300		SAY("  mean"&CRLF&LF);
19400		END "YEARS";
19500	
19600	IF LN(S←ASK("*"))=1 THEN BEGIN "DECODE"
19700	IF (COM←S LAND '137)>"I" THEN BEGIN
19800		IF COM="N" THEN NAME ELSE IF COM="W" THEN WRITE
19900		ELSE IF COM="L" THEN LIST ELSE IF COM="P" THEN PRINT
20000		ELSE IF COM="R" THEN RATINGS ELSE IF COM="T" THEN
20100			BEGIN IF LN(S←ASK("Tasting date:  ")) THEN DATE←S  END
20200		ELSE IF COM ="Y" THEN YEARS
20300		END
20400	ELSE IF (COM←COM-"A")≥0 THEN CASE COM OF BEGIN
20500		BEGIN LIST; RATINGS; DISTRIBUTION; CONSENSUS; YEARS END;  "A"
20600		IF 0≤(BASE←ASK("Base number or letter:  "))≤"9" THEN
20700			BEGIN B←CVD(BASE)-1;  BASE←NULL  END
20800		    ELSE B←0;  "B"
20900		CONSENSUS;  "C"
21000		DISTRIBUTION;  "D"
21100		;	
21200		IF LN(S←ASK("Output file:  ")) THEN FILE←S;  "F"
21300		;
21400		HELP;  "H"
21500		INPUT
21600		END
21700	END "DECODE"
21800	END "COMMANDS"
21900	END "ARRAYS"
22000	END